home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / asm < prev    next >
Encoding:
Text File  |  1992-06-01  |  36.8 KB  |  1,307 lines
  1. \ 00001 25-sep-91 mdh     fixed TYPE13 & TYPE8 size warnings, SIZEM for LEA
  2. \ 00002 01-jun-92 mdh     fixed ;CODE (added [compile])
  3.  
  4. ANEW TASK-ASM
  5.  
  6. max-inline @   6 max-inline ! 
  7. (  68K forth style ASSEMBLER  )
  8. FORTH DEFINITIONS
  9.  
  10. .NEED ASSEMBLER
  11.    VOCABULARY ASSEMBLER
  12. .THEN 
  13. SEARCH-CURRENT ON
  14. ALSO FORTH
  15. ASSEMBLER DEFINITIONS
  16.  
  17. \ variable #REL
  18. \ variable REL-SIZE
  19.  
  20. INCLUDE? RESOLVE-RELS jf:ASM.REF
  21.  
  22. ASSEMBLER DEFINITIONS
  23.  
  24. variable #REGISTERS
  25. variable REGISTER-PENDING
  26. variable JUST-REPORT
  27.  
  28. FORTH DEFINITIONS
  29. : @REG  ( -- , set so that the name can be executed without registering )
  30.   [ also assembler ]  just-report on  [ previous ]  ;
  31.  
  32. ASSEMBLER DEFINITIONS
  33.  
  34. \ these 5 words support printing of the Forward-ASM error message...
  35.  
  36. variable ASMFBLK
  37. variable ASMLINENUM
  38. variable ASMFNAME
  39. variable LINETEXT 80 allot
  40.  
  41. : FASM.WHERE  ( -- )
  42.   ASMFBLK @
  43.   IF
  44.      >newline cr  ." Line " ASMLINENUM @ .   FILEHEADERS @
  45.      IF
  46.         ." of file " ascii " emit
  47.         ASMFNAME @    \ dup 10 dump 
  48.         dup 5 +  swap c@  ( -- nfa+5 nfac@ )
  49.         $ 1f and 4 - type   ascii " emit
  50.      THEN
  51.      cr cr
  52.      LINETEXT count type cr
  53.   THEN
  54. ;
  55.  
  56.  
  57.  
  58.  
  59. : GET-REG   ( pfa -- regv )  @
  60.   Just-Report @  0=
  61.   IF   1 #REGISTERS +!  TRUE REGISTER-PENDING !
  62.   THEN Just-Report OFF  ;
  63.  
  64. HEX
  65. : AREG  CREATE ( reg#---)  ,       DOES>  ( <pfa> -- areg )  GET-REG ;
  66.  
  67. : DREG  CREATE ( reg#---)  10 OR , DOES>  ( <pfa> -- dreg )  GET-REG ;
  68.  
  69. HEX
  70. 0 CONSTANT DN-CODE
  71. 8 CONSTANT AN-CODE
  72. 10 CONSTANT A@-CODE
  73. 18 CONSTANT A@+-CODE
  74. 20 CONSTANT -A@-CODE
  75. 28 CONSTANT AN+W-CODE
  76. 30 CONSTANT AN+R+B-CODE
  77. 38 CONSTANT ABS.W@-CODE
  78. 39 CONSTANT ABS.L@-CODE
  79. 3A CONSTANT PC+W-CODE
  80. 3B CONSTANT PC+R+B-CODE
  81. 3C CONSTANT #-CODE
  82.  
  83. HEX
  84. variable SIZE
  85. variable SIZE-SET?
  86.  
  87. variable QUICK   ( for move default to moveq )
  88.  
  89. variable Size1   variable Size2
  90.  
  91. : SET-SIZE  ( SIZE-CODE---)
  92.      SIZE  !  SIZE-SET? ON
  93. ;
  94.  
  95.  
  96.  0 CONSTANT BYTE-SIZE
  97. 40  CONSTANT WORD-SIZE  ( 1 6 ROTATE-LEFT )
  98. 80 CONSTANT LONG-SIZE  ( 10 6 ROTATE-LEFT  )
  99.  
  100. : BYTE BYTE-SIZE SET-SIZE  ;
  101.  
  102. : WORD WORD-SIZE SET-SIZE  ;
  103.  
  104. : LONG LONG-SIZE SET-SIZE  ;
  105.  
  106. ( 68K   OP-MODE CODES  )
  107. 0           CONSTANT <EA>DN->DN-CODE
  108. 0 8 SET-BIT CONSTANT DN<EA>-><EA>-CODE
  109.  
  110. DECIMAL
  111. variable FATAL?
  112. : FATAL   FATAL? @ IF    [ FORTH ] FORTH DEFINITIONS QUIT
  113.                    THEN     ;
  114.  
  115. : ACR  cr  ( >newline )  ;
  116.  
  117. \ : WHERE  aCR  ; 
  118.  
  119. : WHERE
  120.   ASMFBLK @
  121.   IF
  122.      FASM.WHERE
  123.   ELSE
  124.      WHERE
  125.   THEN
  126.   ?pause
  127. ;
  128.  
  129.  
  130.    5 ARRAY SOURCE-ARRAY
  131.    5 ARRAY DESTINATION-ARRAY
  132.  
  133. variable SOURCE-STATE
  134. variable DESTINATION-STATE
  135.  
  136. : INIT-ASM ( --- )
  137.      Just-Report off
  138.      0          #REGISTERS           !
  139.      0          REGISTER-PENDING     !
  140.      LONG-SIZE  SIZE                 !
  141.      0          SIZE-SET?            !
  142.      0          QUICK                !
  143.      0          SOURCE-STATE         !
  144.      0          DESTINATION-STATE    !
  145.      0 0 0 0 0  0 SOURCE-ARRAY      5 X!
  146.      0 0 0 0 0  0 DESTINATION-ARRAY 5 X!   ;
  147.  
  148. also assembler
  149.  
  150. : <ERROR>   acr HERE COUNT SAFETYPE  ."  ? ASSEMBLER error"
  151.   CLINESTART @  CPREVSTART @  CLINENUM @
  152.   WHERE  ( ONLY FORTH DEFINITIONS )
  153.   CLINENUM !  CPREVSTART !  CLINESTART !  ;
  154.  
  155. : starterr  >newline ." ----------------" cr ;
  156.  
  157. : ERROR  ( MSG#-- )  
  158.   starterr DROP  INIT-ASM   <ERROR>  ;
  159.  
  160. : $ERROR  ( $ -- )
  161.   starterr  $type cr INIT-ASM   <ERROR>  ;
  162.  
  163. : "ILLEGAL 
  164.   starterr $type   ."  ILLEGAL: " cr <ERROR> ;
  165.  
  166. previous
  167.  
  168. : HAVE-SOURCE? ( --F )  SOURCE-STATE @ ;
  169. : HAVE-DESTINATION? ( --F )  DESTINATION-STATE @ ;
  170.  
  171. : HAVE-SOURCE    1 SOURCE-STATE ! ;
  172. : HAVE-DESTINATION 1 DESTINATION-STATE ! ;
  173.  
  174. : CLR-SOURCE   0 SOURCE-STATE !  0 SOURCE-ARRAY 10 0 FILL ;
  175. : CLR-DESTINATION 0 DESTINATION-STATE !
  176.    0 DESTINATION-ARRAY 10 0 FILL ;
  177.  
  178. : GET-SOURCE-EA      ( --EA ) 0 SOURCE-ARRAY      @ ;
  179. : GET-DESTINATION-EA ( --EA ) 0 DESTINATION-ARRAY @ ;
  180.  
  181. : ADDRESS-ARRAY ( N ARRAY-OFFSET---)  HAVE-SOURCE?
  182.       IF   DESTINATION-ARRAY
  183.       ELSE  SOURCE-ARRAY
  184.       THEN  ;
  185.  
  186. : ADDRESS-ARRAY!  ( N ARRAY-OFFSET --- )  ADDRESS-ARRAY ! ;
  187.  
  188. : ADDRESS-ARRAY@  ( ARRAY-OFFSET --- WORD )  ADDRESS-ARRAY @ ;
  189.  
  190. BINARY
  191. : GET-MODE  ( 0-ARRAY-@ -- *-CODE )
  192.         DUP 111000 AND 111000 =
  193.           IF   111111 AND
  194.           ELSE 111000 AND
  195.           THEN     ;
  196.  
  197. : GET-SOURCE-MODE   ( -- *-CODE )
  198.      GET-SOURCE-EA GET-MODE ;
  199.  
  200. : GET-DESTINATION-MODE  ( -- *-CODE )
  201.       GET-DESTINATION-EA GET-MODE ;
  202.  
  203. BINARY
  204. : REGISTER#-ONLY  ( STRIP OFF MODE )    111  AND   ;
  205. : GET-SOURCE-REGISTER ( --REG# )
  206.          GET-SOURCE-EA   REGISTER#-ONLY  ;
  207. : GET-DESTINATION-REGISTER  ( --REG# )
  208.          GET-DESTINATION-EA   REGISTER#-ONLY  ;
  209.  
  210. DECIMAL  
  211. : EXTENDED? ( MODE+REG---FLAG) ( IF BINARY 111XXX )
  212.    [ BINARY ]   111000 AND   111000 = [ DECIMAL ] ;
  213.  
  214. : SWAP-SOURCE-DEST  ( SWAP SOURCE AND DESTINATION ARRAY VALUES )
  215.        5 0 DO  I SOURCE-ARRAY @  I DESTINATION-ARRAY @
  216.                I SOURCE-ARRAY !  I DESTINATION-ARRAY !
  217.            LOOP  ;
  218.  
  219. : R+B-REGISTER-TYPE ( [EXT] ADDR---[EXT]' ADDR )
  220.    DUP CELL+ @ [ HEX ] 10 AND  ( 0 ARRAY-ADDR MODE ---)
  221.        IF  ( DREG )
  222.        ELSE ( AREG )  SWAP [ DECIMAL ] 15 SET-BIT SWAP
  223.        THEN       ;
  224.  
  225. : R+B-REGISTER  ( [EXT] ADDR---[EXT]' ADDR )
  226.     DUP CELL+ @ [ BINARY ] 111 AND [ DECIMAL ] 12 +SHIFT
  227.     ( [EXT] ARRAY-ADDR REG-BITS---)  ROT OR SWAP   ;
  228.  
  229. : R+B-OFFSET  ( [EXT] ADDR---[EXT]' ADDR )  [ HEX ]
  230.  DUP >R   2 CELLS +  @ 00FF AND ( OFFSET ) OR  R>  ; DECIMAL
  231.  
  232. : R+B-SIZE  ( [EXT] ARRAY-ADDR --- [EXT]' ADDR )
  233.       DUP 4 CELLS + @  DUP -1 =
  234.       IF    DROP  LONG-SIZE  ( SIZE @ )
  235.       THEN
  236.   CASE  ( [EXT] ADDR MODE-SIZE --- )
  237.    BYTE-SIZE   OF  " BYTE +R+B EXTENTION"  "ILLEGAL  ENDOF
  238.    WORD-SIZE   OF                                       ENDOF
  239.    LONG-SIZE   OF SWAP [ DECIMAL ] 11 SET-BIT  SWAP     ENDOF
  240.       drop " R+B-SIZE: SIZE" "ILLEGAL
  241.   ENDCASE        ;
  242.  
  243. : DO-R+B  ( ARRAY-ADDR---)   0 ( INIT [EXT] )  SWAP
  244.   ( [EXT] ARRAY-ADDR---)
  245.   R+B-REGISTER-TYPE
  246.   R+B-REGISTER
  247.   R+B-SIZE
  248.   R+B-OFFSET
  249.   DROP    W,(T)   ;
  250.  
  251. : DO-#   ( ARRAY-ADDR---)  SIZE @
  252.   CASE
  253.       BYTE-SIZE   OF  CELL+ @  [ HEX ] 0FF AND  ABSOLUTE ENDOF
  254.       WORD-SIZE   OF  CELL+ @   ABSOLUTE                 ENDOF
  255.       LONG-SIZE   OF (  DUP 2 CELLS + @ W,<T> )
  256.                      CELL+ @ D-ABSOLUTE                  ENDOF
  257.         DROP " DO-#: SIZE"  "ILLEGAL  
  258.   ENDCASE  ;
  259.  
  260. BINARY
  261. : ADD-EXTENDED-[EXT]  ( ARRAY-ADDR---)  DUP @   111111 AND
  262.    CASE
  263.       ABS.W@-CODE  OF   CELL+ @ ABSOLUTE     ENDOF
  264.       ABS.L@-CODE  OF  CELL+ @ D-ABSOLUTE    ENDOF
  265.       PC+W-CODE    OF  CELL+   @ W,(T)       ENDOF
  266.       PC+R+B-CODE  OF  DO-R+B                ENDOF
  267.       #-CODE       OF  DO-#                  ENDOF
  268.        DROP  " MODE REQUIRING EXTENSION" "ILLEGAL 
  269.    ENDCASE   ;
  270.  
  271. : ADD-REGULAR-[EXT]  ( ARRAY-ADDR---)  DUP @ 111000 AND
  272.    CASE
  273.       AN+W-CODE    OF  CELL+ @  W,(T)    ENDOF
  274.       AN+R+B-CODE  OF  DO-R+B            ENDOF
  275.      DROP  ( IF NOT [EXT] AT ALL )
  276.    ENDCASE         ; 
  277.  
  278. BINARY
  279. : ADD-[EXT]  ( ARRAY-ADDR---)  DUP @   EXTENDED?
  280.    IF    ADD-EXTENDED-[EXT]
  281.    ELSE  ADD-REGULAR-[EXT]
  282.    THEN ;
  283.  
  284. DECIMAL
  285. : [EXT]  ( ---) ( ADD EXTENTIONS IF ANY )
  286.    0 SOURCE-ARRAY        ADD-[EXT]
  287.    0 DESTINATION-ARRAY   ADD-[EXT]    ;
  288.  
  289.  
  290. : A-FINIS  [EXT]  INIT-ASM  ;
  291.  
  292. variable ASMWasQuit
  293. variable ASMWasHeadTail
  294.  
  295. : CLEANUPASSEM  ( -- , cause module to get hidden )
  296.   only forth
  297. [ EXISTS? ASSEM .IF ]
  298.     ' ASSEM  (hidemod)
  299. [ .THEN ]
  300.    ASMWasHeadTail @ HeadTail !
  301.    asmwasquit @ dup is quit  execute
  302. ;
  303.  
  304. FORTH DEFINITIONS
  305.  
  306. : <RES-CODE> ( --- ) ( name --in-- )    ?EXEC   (CREATE) 
  307.    ALSO ASSEMBLER   !CSP  [  ASSEMBLER ] #rel off INIT-ASM
  308.    HeadTail @ ASMWasHeadTail !
  309.    HeadTail off
  310.    what's quit ASMWasQuit !
  311.       " CLEANUPASSEM" find
  312.    IF   is quit
  313.    ELSE
  314.        " <RES-CODE>: Dictionary Error" [ also forth ] $error [ previous ]
  315.    THEN
  316.    -1 dpl !  ( fix in case 1,2,3 # used which don't set dpl )
  317. ;
  318.  
  319. EXISTS? ASSEM .IF
  320.   : CODE  <RES-CODE>  ;
  321. .THEN
  322.  
  323. : <RES-;CODE>  ( --- )  ?CSP  !CSP
  324.    ALSO ASSEMBLER      [ ASSEMBLER ] INIT-ASM
  325.    [] [  ; IMMEDIATE
  326.  
  327. EXISTS? ASSEM .IF
  328.   : ;CODE  [compile] <RES-;CODE>  ;  IMMEDIATE   \ 00002
  329. .THEN
  330.  
  331.  
  332. ASSEMBLER DEFINITIONS
  333. : <RES-END-CODE>   (  --- )  RESOLVE-RELS  ?EXEC \ UNSMUDGE
  334.   PREVIOUS    INIT-ASM  CSP @ SP@ CELL+ - \ -DUP
  335.   IF
  336.      \ acr " CODE stack error while assembling " LATEST  ID.
  337.      \ ASCII , EMIT   SPACE   CELL/ . ." cell(s) " .S
  338.        " Stack error while assembling "  pad $move
  339.        LATEST c@ $ 1f and  LATEST 1+ swap  pad $append  pad  $error
  340.   ELSE
  341.      here 2- w@ $ 4e75 =
  342.      IF   -2 dp +!
  343.      THEN  ( FixHash; )  1 state !  [compile] ;
  344.   THEN
  345.   ASMWasHeadTail @ HeadTail !
  346.   ASMWasQuit @ is quit
  347. ;
  348.  
  349. FORTH DEFINITIONS
  350.  
  351. EXISTS? ASSEM .IF
  352.   : END-CODE  [ ASSEMBLER ]  <RES-END-CODE>  ;
  353. .THEN
  354.  
  355.  
  356. .NEED ASSEM
  357. : RESIDENT-ASM  ( --- )   [  ASSEMBLER ]
  358.  
  359.   '  <RES-BYTE-RELATIVE>     IS    BYTE-RELATIVE    
  360.   '  <RES-WORD-RELATIVE>     IS    WORD-RELATIVE    
  361.   '  <RES-ABSOLUTE>          IS    ABSOLUTE         
  362.   '  <RES-D-ABSOLUTE>        IS    D-ABSOLUTE       
  363.   '  <RES-W,(T)>             IS    W,(T)            
  364.   '  <RES-MARK>              IS    MARK             
  365.   '  <RES-CODE>              IS    CODE             
  366.   '  <RES-;CODE>             IS    ;CODE            
  367.   '  <RES-END-CODE>          IS    END-CODE
  368.  
  369. ;
  370. .ELSE
  371.  
  372. : RESIDENT-ASM ;
  373.  
  374. .THEN
  375.  
  376. RESIDENT-ASM
  377.  
  378.  
  379. ASSEMBLER DEFINITIONS
  380. DECIMAL
  381. here   variable MASKS  masks !   ( ADDRESS OF CURRENT MASK PFA )
  382. : CREATE-MASK   ( OFFSET --- offset' ) 
  383.       CREATE DUP ,  CELL+
  384.       DOES>  ( ---ADDRESS )     @ MASKS @ +  ;
  385.  
  386. 0 ( START OF MASKS )
  387. CREATE-MASK OPCODEM
  388. CREATE-MASK SIZEM
  389. CREATE-MASK SOURCEM
  390. CREATE-MASK DESTINATIONM
  391. CREATE-MASK EXCEPTIONM
  392.    CONSTANT MASK-SPACE  ( USE UP OFFSET FOR SIZE )
  393.  
  394. : ALLOT-SPACE  HERE MASKS !   MASK-SPACE CELL/   0
  395.        DO  0 ,    LOOP  ;
  396.  
  397. DECIMAL
  398. : OPCODE,  ( OPCODE--)  OPCODEM ! ;
  399.  
  400. : SIZEM,   ( SIZEM--)   SIZEM ! ;
  401.  
  402. : SOURCEM, ( SOURCEM--) SOURCEM ! ;
  403.  
  404. : DESTM,   ( DESTM--)   DESTINATIONM ! ;
  405.  
  406. : EXC,  ( EXCEPTIONM---)  EXCEPTIONM !  ;
  407.  
  408. : CHECK-SIZE  ( XXX-SIZE MASK---)
  409.         AND NOT IF  ( NOT ALLOWED )   SIZE @
  410.   CASE BYTE-SIZE OF " BYTE "   ENDOF
  411.        WORD-SIZE OF " WORD "   ENDOF
  412.        LONG-SIZE OF " LONG "   ENDOF
  413.                " CHECK-SIZE: SIZE"
  414.   ENDCASE  "ILLEGAL  THEN ;
  415.  
  416. : SIZE? ( --- ) SIZEM @  ( GET SIZE ) SIZE @
  417.   CASE  ( SIZEM SIZE--) [ BINARY ]
  418.            BYTE-SIZE OF  100  CHECK-SIZE  ENDOF
  419.            WORD-SIZE OF  010  CHECK-SIZE  ENDOF
  420.            LONG-SIZE OF  001  CHECK-SIZE  ENDOF
  421.     " SIZE?: SIZE" "ILLEGAL
  422.   ENDCASE   ;   
  423.  
  424. BINARY
  425. : PRINT-SIZE-FROM-BIT  ( SIZE-BIT--)
  426.         CASE  100 OF ." BYTE "  ENDOF
  427.               010 OF ." WORD "  ENDOF
  428.               001 OF ." LONG "  ENDOF  
  429.         ENDCASE  ;
  430.  
  431. : SIZEM->SIZE  ( sizem -- size )
  432.   CASE  [ BINARY ]
  433.        100  OF  BYTE-SIZE   ENDOF
  434.        010  OF  WORD-SIZE   ENDOF
  435.        001  OF  LONG-SIZE   ENDOF
  436.     " SIZEM->SIZE: SIZE" "ILLEGAL  0 swap
  437.   ENDCASE 
  438. ;
  439.  
  440. : SIZE->SIZEM  ( ??-size -- sizem )
  441.   CASE  ( SIZE--) [ BINARY ]
  442.        BYTE-SIZE OF  100  ENDOF
  443.        WORD-SIZE OF  010  ENDOF
  444.        LONG-SIZE OF  001  ENDOF
  445.     " SIZE->SIZEM: SIZE" "ILLEGAL  0 swap
  446.   ENDCASE 
  447. ;
  448.  
  449. : SIZE-OK?  ( SIZE-BIT---) SIZEM @ SWAP  OVER AND NOT
  450.   IF  ( NOT OK ) acr   SIZE @
  451.        CASE BYTE-SIZE OF ." BYTE "   ENDOF
  452.             WORD-SIZE OF ." WORD "   ENDOF
  453.             LONG-SIZE OF ." LONG "   ENDOF
  454.        ENDCASE ." IGNORED, " PRINT-SIZE-FROM-BIT ." USED: "  TYPE-HERE acr
  455.   ELSE drop
  456.   THEN   ;
  457.  
  458. BINARY
  459. : SIZE-WARNING? ( --- ) SIZE-SET? @ 
  460.   IF ( CHECK MASK ) ( SIZEM @ -- removed mdh 02/02/86 )
  461.      ( GET SIZE ) SIZE @
  462.       CASE  ( SIZEM SIZE--) [ BINARY ]
  463.            BYTE-SIZE OF  100  SIZE-OK?  ENDOF
  464.            WORD-SIZE OF  010  SIZE-OK?  ENDOF
  465.            LONG-SIZE OF  001  SIZE-OK?  ENDOF
  466.         " SIZE-WARNING?: SIZE" "ILLEGAL
  467.       ENDCASE 
  468.   THEN   ;   
  469.  
  470. : ENFORCE-MY-SIZE  ( -- )
  471.   size-set? @
  472.   IF
  473.      size @ size->sizem size-ok?
  474.   THEN
  475.   sizem @ sizem->size size !
  476. ;
  477.  
  478. .NEED BIT-CLR?
  479.  : BIT-CLR?  ( N #BIT --- FLAG ) BIT-SET? NOT ;
  480. .THEN 
  481.  
  482. DECIMAL
  483. : CHECK-REGULAR-MODES  ( MODE-MASK MODE---)  [ HEX ] 38 AND [ DECIMAL ]  
  484.  CASE
  485.      DN-CODE   OF 11 BIT-CLR? IF " DN"     "ILLEGAL THEN ENDOF
  486.      AN-CODE   OF 10 BIT-CLR? IF " AN"     "ILLEGAL THEN ENDOF
  487.      A@-CODE   OF 9  BIT-CLR? IF " A@"     "ILLEGAL THEN ENDOF
  488.     A@+-CODE   OF 8  BIT-CLR? IF " A@+"    "ILLEGAL THEN ENDOF
  489.     -A@-CODE   OF 7  BIT-CLR? IF " -A@"    "ILLEGAL THEN ENDOF
  490.    AN+W-CODE   OF 6  BIT-CLR? IF " AN+W"   "ILLEGAL THEN ENDOF
  491.    AN+R+B-CODE OF 5  BIT-CLR? IF " AN+R+B" "ILLEGAL THEN ENDOF
  492.         " MODE" "ILLEGAL 
  493.  ENDCASE      ;
  494.  
  495. DECIMAL
  496. : CHECK-EXTENDED-MODES  ( MODE-MASK MODE---)   63 AND  
  497.   CASE
  498.     ABS.W@-CODE OF 4 BIT-CLR? IF " ABS.W@"  "ILLEGAL THEN ENDOF
  499.     ABS.L@-CODE OF 3 BIT-CLR? IF " ABS.L@"  "ILLEGAL THEN ENDOF
  500.     PC+W-CODE   OF 2 BIT-CLR? IF " PC+W"    "ILLEGAL THEN ENDOF
  501.     PC+R+B-CODE OF 1 BIT-CLR? IF " PC+R+B"  "ILLEGAL THEN ENDOF
  502.     #-CODE      OF 0 BIT-CLR? IF " #"       "ILLEGAL THEN ENDOF
  503.        " MODE" "ILLEGAL 
  504.   ENDCASE   ;   
  505.  
  506. : CHECK-ADDRESS-MODE  ( MODE-MASK MODE---)  DUP 56 AND  ABS.W@-CODE = 
  507.     IF   CHECK-EXTENDED-MODES
  508.     ELSE CHECK-REGULAR-MODES
  509.     THEN  ;
  510.  
  511. : SOURCE? ( --- ) SOURCEM @ GET-SOURCE-EA
  512.           CHECK-ADDRESS-MODE  ;
  513.  
  514. : DESTINATION? ( --- )  DESTINATIONM @ GET-DESTINATION-EA
  515.           CHECK-ADDRESS-MODE  ;
  516.  
  517. : SOURCE-NOT-DN-OK?  ( --- )
  518.      EXCEPTIONM @  1 BIT-SET?
  519.         IF " SOURCE OTHER THAN DN " "ILLEGAL   THEN  ;
  520.  
  521. : DEST-NOT-DN-OK?  ( --- )
  522.      EXCEPTIONM @  0 BIT-SET?
  523.         IF " DESTINATION OTHER THAN DN " "ILLEGAL THEN  ;
  524.  
  525. FALSE .IF
  526.   68k assembler  explaination of masks: 
  527.   sizem, compiles size mask in binary a mask is  3 bits. 
  528.   byte,word,long, sourcem, compiles source mask in 12 bits binary 
  529.   the bits are as the modes are listed in the motorola 68000 user's manual  
  530.   destm,  is as sourcem, for the destination mask 
  531. .THEN
  532.  
  533. BINARY
  534. : ?AN/BYTE/SOURCE  ( --- ) ( ERROR IF BYTE AND AN )
  535.     SIZE @ BYTE-SIZE =
  536.      IF      GET-SOURCE-MODE   AN-CODE =
  537.              IF " SOURCE AN WITH BYTE" "ILLEGAL  THEN
  538.      THEN  ;
  539.  
  540. : ?AN/BYTE/DESTINATION  ( --- )
  541.   SIZE @ BYTE-SIZE =
  542.   IF    GET-DESTINATION-MODE   AN-CODE =
  543.         IF    " DESTINATION AN WITH BYTE" "ILLEGAL  THEN
  544.   THEN    ;
  545.  
  546. DECIMAL
  547. : ?AN/BYTE  ( --- )   EXCEPTIONM @
  548.        DUP 2 BIT-SET?
  549.        IF    ?AN/BYTE/SOURCE  DROP
  550.        ELSE    4 BIT-SET?
  551.                IF     ?AN/BYTE/DESTINATION
  552.                THEN
  553.        THEN           ;
  554.  
  555. BINARY
  556. : TYPE1   CREATE  ALLOT-SPACE  OPCODE,
  557.           DOES>      @ W,(T)  INIT-ASM         ;
  558.  
  559. : TYPE2   CREATE  ALLOT-SPACE   OPCODE,  010 SIZEM,  1 SOURCEM,
  560.           DOES>    MASKS !  WORD-SIZE SIZE !  SIZE-WARNING?  SOURCE?
  561.                    OPCODEM @ W,(T) 0 SOURCE-ARRAY DO-#
  562.                    INIT-ASM  ;
  563.  
  564. : TYPE3  CREATE  ALLOT-SPACE  OPCODE,  100 SIZEM, 1 SOURCEM,
  565.          DOES>    MASKS !   BYTE-SIZE SIZE !  SIZE-WARNING?   SOURCE?
  566.                   OPCODEM @ W,(T) 0 SOURCE-ARRAY DO-#
  567.                   INIT-ASM     ;
  568.  
  569. : TYPE4 ( SIZEM SOURCEM OPCODE-- )
  570.         CREATE   ALLOT-SPACE   OPCODE,  101111111000 SOURCEM,
  571.                       111 SIZEM,
  572.          DOES>   MASKS !    SIZE?    SOURCE?  OPCODEM @
  573.                   SIZE @ OR GET-SOURCE-EA OR  W,(T)  A-FINIS ;
  574.  
  575. : TYPE5 ( SIZEM SOURCEM OPCODE-- )
  576.   CREATE   ALLOT-SPACE  OPCODE,  101111111000 DESTM,  1 SOURCEM,
  577.                 111 SIZEM,
  578.    DOES>    MASKS ! SIZE? DESTINATION? SOURCE? OPCODEM @
  579.             SIZE @ OR GET-DESTINATION-EA OR  W,(T)   A-FINIS  ;
  580.  
  581. DECIMAL
  582. : ALT/MOVE/SIZE   ( SIZE-MASK---ALT/MOVE-SIZE-MASK  )
  583.  CASE
  584.      BYTE-SIZE  OF  [ BINARY 1 DECIMAL 12 +SHIFT  ] LITERAL  ENDOF
  585.      WORD-SIZE  OF  [ BINARY 11 DECIMAL 12 +SHIFT ] LITERAL  ENDOF
  586.      LONG-SIZE  OF  [ BINARY 10 DECIMAL 12 +SHIFT ] LITERAL  ENDOF
  587.  ENDCASE    ;
  588.  
  589. : TO-MOVE/DESTINATION   ( SOURCE<EA>---DESTINATION<EA> )
  590.     DUP [ BINARY ]  111    [ DECIMAL ] AND 9 +SHIFT
  591.    SWAP [ BINARY ]  111000 [ DECIMAL ] AND 3 +SHIFT OR  ;
  592.  
  593. BINARY
  594. : TYPE7-AN  ( OPCODE--OPCODE' )  SIZE @
  595.     CASE    WORD-SIZE   OF   011000000    ENDOF
  596.             LONG-SIZE   OF   111000000    ENDOF
  597.             " BYTE WITH AN DESTINATION" "ILLEGAL
  598.     ENDCASE    OR    ;
  599.  
  600. HEX
  601. : EOR-OR-CMP   ( --OPCODE )   SOURCEM @  7FF AND
  602.   [ BINARY ]   IF   1100
  603.                ELSE 1010
  604.                THEN   ;
  605. DECIMAL
  606. : CONVERT-OPCODE ( OPCODE--OPCODE' )
  607.       12 -SHIFT  [ BINARY ]
  608.       CASE  1000 ( OR  )  OF  0000  ENDOF
  609.             1001 ( SUB )  OF  0100  ENDOF
  610.             1100 ( AND )  OF  0010  ENDOF
  611.             1101 ( ADD )  OF  0110  ENDOF
  612.             1011 ( ??? )  OF  EOR-OR-CMP  ENDOF
  613.        " TYPE7-#, NON-CONVERTABLE OPCODE: "  $ERROR 
  614.       ENDCASE    [ DECIMAL ]   8 +SHIFT    ;
  615.  
  616. BINARY
  617. : TYPE7-#   ( OPCODE--OPCODE' )
  618.         DROP
  619.         101111111000  GET-DESTINATION-EA  CHECK-ADDRESS-MODE
  620.         OPCODEM @ CONVERT-OPCODE
  621.         GET-DESTINATION-EA   OR
  622.         SIZE @ OR    ;
  623.  
  624. DECIMAL 
  625. : TYPE7-SRC-DN   ( TRUE-IF-SRC-DN --- )
  626.             DESTINATION?  0=   ( DEST-NOT-DN? )
  627.             EXCEPTIONM @ 1 BIT-SET?  ( IS IT EOR? )   OR
  628.             IF DN<EA>-><EA>-CODE OR
  629.                SWAP-SOURCE-DEST
  630.             THEN      ;
  631.  
  632. : TYPE7-OP-MODE  ( OPCODE --- OPCODE+OPMODE F  )
  633.   GET-DESTINATION-MODE AN-CODE = EXCEPTIONM @ 3 BIT-SET? AND
  634.   IF TYPE7-AN
  635.   ELSE GET-DESTINATION-MODE DN-CODE = GET-SOURCE-MODE DN-CODE =
  636.      2DUP 0= IF SOURCE-NOT-DN-OK? THEN
  637.           0= IF DEST-NOT-DN-OK? THEN
  638.         IF TYPE7-SRC-DN
  639.         ELSE IF <EA>DN->DN-CODE OR
  640.              ELSE  " <EA>,DN <EA>,AN #,<EA> ONLY: "  $ERROR
  641.              THEN
  642.         THEN
  643.      SIZE @ OR
  644.   THEN    ;
  645.  
  646. DECIMAL
  647. : TYPE7 ( EXC DESTM SOURCEM OPCODE-- )
  648.         CREATE   ALLOT-SPACE
  649.                   OPCODE,  SOURCEM,  DESTM,  EXC,
  650.          DOES>   MASKS !  OPCODEM @
  651.              GET-SOURCE-MODE #-CODE =
  652.              GET-DESTINATION-MODE AN-CODE = NOT  AND
  653.                IF TYPE7-#
  654.                ELSE   TYPE7-OP-MODE
  655.                   GET-SOURCE-EA   OR
  656.                   GET-DESTINATION-REGISTER
  657.                   9 +SHIFT  OR   ?AN/BYTE
  658.                THEN   W,(T) A-FINIS   ;
  659.  
  660. DECIMAL
  661. : TYPE8 ( SOURCEM DESTM SIZEM OPCODE-- )
  662.   CREATE
  663.      ALLOT-SPACE
  664.      OPCODE,  SIZEM,  DESTM,  SOURCEM,
  665.   DOES>
  666.      MASKS !  ENFORCE-MY-SIZE
  667.      SOURCE?  DESTINATION?  OPCODEM @
  668.      GET-SOURCE-EA   OR
  669.      GET-DESTINATION-REGISTER
  670.      9 +SHIFT  OR  W,(T)   A-FINIS   ;
  671.  
  672. BINARY       (  <DATA> #   <EA>   <SIZE>   <FUNCT>Q     )
  673. : TYPE9 ( SIZEM SOURCEM OPCODE-- )
  674.    CREATE   ALLOT-SPACE
  675.              OPCODE,  SIZEM,  DESTM,   1 SOURCEM,
  676.     DOES>    MASKS ! SIZE? SOURCE? DESTINATION? OPCODEM @
  677.              SIZE @ OR GET-DESTINATION-EA OR
  678.              1 SOURCE-ARRAY @
  679.              111 AND [ DECIMAL ] 9 +SHIFT OR
  680.              ?AN/BYTE/SOURCE   W,(T) CLR-SOURCE  A-FINIS  ;
  681.  
  682. DECIMAL
  683. : ALT/SIZE  ( SIZE-MASK---ALT-SIZE-MASK )
  684.      CASE
  685.     BYTE-SIZE  OF  0                 ENDOF
  686.     WORD-SIZE  OF  [  BINARY 10 DECIMAL 6 +SHIFT ]
  687.                       LITERAL        ENDOF
  688.     LONG-SIZE  OF  [ BINARY 11 DECIMAL 6 +SHIFT ]
  689.                       LITERAL        ENDOF
  690.       ENDCASE  ;
  691.  
  692. : ALT/SIZE?  ( SIZE---SIZE1 )  ( ALT/SIZE IF EXC MASK SET )
  693.    EXCEPTIONM @  3 BIT-CLR?
  694.      IF
  695.      ELSE  ALT/SIZE
  696.      THEN   ;
  697.  
  698. \ TYPE10: SWAP UNLK  EXT  MOVE-FROM-USP  MOVE-TO-USP 
  699. : TYPE10    ( EXC SOURCEM SIZEM OPCODE---)
  700.         CREATE   ALLOT-SPACE  OPCODE,  SIZEM, SOURCEM,
  701.         DOES>   MASKS !   SOURCE?  SIZE-WARNING?
  702.                 OPCODEM @   GET-SOURCE-REGISTER  OR
  703.                 W,(T) A-FINIS   ;
  704.  
  705. : TYPE10.5    (  SOURCEM SIZEM OPCODE---)
  706.         CREATE   ALLOT-SPACE  OPCODE,  SIZEM, SOURCEM,
  707.         DOES>   MASKS !   SOURCE?  SIZE?
  708.                 OPCODEM @  SIZE @   ALT/SIZE  OR
  709.                 GET-SOURCE-REGISTER  OR
  710.                 W,(T) A-FINIS   ;
  711.  
  712. \  TYPE11:    JMP JSR TAS PEA NBCD MOVE-TO-'S 
  713. DECIMAL
  714. : TYPE11 ( SIZEM SOURCEM OPCODE-- )
  715.         CREATE   ALLOT-SPACE
  716.                   OPCODE,  SIZEM,  SOURCEM,
  717.          DOES>    MASKS ! SOURCE?  SIZE-WARNING?  OPCODEM @
  718.                   GET-SOURCE-EA   OR  W,(T)
  719.                   A-FINIS   ;
  720.  
  721. DECIMAL
  722. : DO-EXG/OPMODE   ( OPCODE---OPCODE' )
  723.        GET-SOURCE-MODE  GET-DESTINATION-MODE
  724.        DN-CODE = abs  SWAP DN-CODE = abs 2*   OR
  725. [ BINARY ] CASE ( <SOURCE-DN?-FLAG*2--OR--DESTINATION-DN?> --)
  726. 11 OF [ BINARY 01000 HEX 3 +SHIFT BINARY ] LITERAL  ENDOF
  727. 00 OF [ BINARY 01001 HEX 3 +SHIFT BINARY ] LITERAL  ENDOF
  728. 01 OF [ BINARY 10001 HEX 3 +SHIFT BINARY ] LITERAL  ENDOF
  729. 10 OF SWAP-SOURCE-DEST
  730.       [ BINARY 10001 HEX 3 +SHIFT BINARY ] LITERAL  ENDOF
  731.          ENDCASE   OR  ;
  732. HEX
  733. : DO-RX-RY  ( OPCODE---OPCODE' )
  734.   GET-SOURCE-REGISTER      OR
  735.   GET-DESTINATION-REGISTER  9 +SHIFT OR  ;
  736.  
  737. \ TYPE12:  EXG
  738. BINARY
  739. : TYPE12
  740.         CREATE   ALLOT-SPACE
  741.       110000000000 SOURCEM,  110000000000 DESTM,
  742.       001 SIZEM,  1100000100000000  OPCODE,
  743.          DOES>  MASKS !  SOURCE? DESTINATION?  SIZE-WARNING?
  744.                 OPCODEM @
  745.                 DO-EXG/OPMODE  DO-RX-RY  W,(T)  A-FINIS ;
  746. BINARY
  747. : DO-#SHIFT ( ---OPCODE' )    DESTINATION?
  748.          1 SOURCE-ARRAY @ 111 AND [ DECIMAL ]   9 +SHIFT ;
  749. DECIMAL
  750. : DO-DN-SHIFT ( ---OPCODE' )  GET-SOURCE-REGISTER  9 +SHIFT
  751.    5 SET-BIT ;
  752.  
  753. : DO-NON-<EA>  ( ---OPCODE )  GET-SOURCE-MODE  #-CODE =
  754.     IF    DO-#SHIFT
  755.     ELSE  DO-DN-SHIFT
  756.     THEN  OPCODEM @
  757.     [ BINARY 111011 DECIMAL 6 +SHIFT -1 XOR ] LITERAL AND
  758.     OR  SIZE @ OR   GET-DESTINATION-REGISTER OR
  759.    CLR-SOURCE  CLR-DESTINATION   ;
  760.  
  761. ( TYPE13:  SHIFT ROTATE  )
  762. BINARY
  763. : TYPE13
  764.   CREATE ( OPCODE -) ALLOT-SPACE  OPCODE,  010 SIZEM,
  765.   001111111000 SOURCEM,  100000000000 DESTM,
  766.   DOES>   ( <PFA> --- ) MASKS  !
  767.   GET-SOURCE-MODE  DUP #-CODE = SWAP DN-CODE = OR NOT
  768.   IF
  769.      ( SIZE? - removed 00001 )  size @ size->sizem size-ok?
  770.      SOURCE?  OPCODEM @  111000 -1 XOR AND
  771.      GET-SOURCE-EA OR
  772.   ELSE
  773.      DO-NON-<EA>
  774.   THEN  W,(T)   A-FINIS  ;
  775.  
  776. \ DX DY ---
  777. \ #  DY ---
  778. \ <ea>  ---  ( once )
  779.  
  780. ( TYPE14:   EXTENDED  )
  781. BINARY
  782. : TYPE14 
  783.     CREATE  ( dest-mask opcode --- )  ALLOT-SPACE  OPCODE,
  784.            100010000000  DUP SOURCEM,  DESTM,  [ DECIMAL ]  
  785.      DOES>  MASKS !   SOURCE?  DESTINATION? OPCODEM @
  786.             GET-SOURCE-MODE  DN-CODE =
  787.             IF    GET-DESTINATION-MODE  DN-CODE = NOT
  788.                   IF     " NOT DN" "ILLEGAL
  789.                   THEN
  790.             ELSE  GET-DESTINATION-MODE  -A@-CODE = NOT
  791.                   IF     " BOTH NOT -A@"  "ILLEGAL
  792.                   THEN  3 SET-BIT
  793.             THEN  GET-SOURCE-REGISTER OR
  794.             GET-DESTINATION-REGISTER 9 +SHIFT OR
  795.             SIZE @ OR  W,(T)  A-FINIS  ;
  796.  
  797. ( TYPE15:  SBCD  ABCD  )
  798. BINARY 
  799. ( NOTE THIS IS ALMOST IDENTICAL TO TYPE14 )
  800. : TYPE15  
  801.     CREATE     ALLOT-SPACE  OPCODE, 100 SIZEM,
  802.            100010000000  DUP SOURCEM,  DESTM,  [ DECIMAL ] 
  803.      DOES>  MASKS !   SOURCE?  DESTINATION? SIZE?
  804.            OPCODEM @  GET-SOURCE-MODE  DN-CODE =
  805.            IF    GET-DESTINATION-MODE  DN-CODE = NOT
  806.                  IF " NOT DN" "ILLEGAL
  807.                  THEN
  808.           ELSE  GET-DESTINATION-MODE  -A@-CODE = NOT
  809.                 IF " BOTH NOT -A@"  "ILLEGAL
  810.                 THEN  3 SET-BIT
  811.            THEN  GET-SOURCE-REGISTER OR
  812.            GET-DESTINATION-REGISTER 9 +SHIFT OR  W,(T)  A-FINIS  ;
  813.  
  814. BINARY
  815. : MOVEP  000000100001000 ( OPCODEM ) [ DECIMAL ]
  816.   GET-SOURCE-MODE  DN-CODE =
  817.          IF acr   GET-DESTINATION-MODE  AN+W-CODE = NOT
  818.                IF    " NOT AN+W"  "ILLEGAL  THEN
  819.               7 SET-BIT  GET-DESTINATION-REGISTER OR
  820.               GET-SOURCE-REGISTER  9 +SHIFT  OR
  821.          ELSE  GET-SOURCE-MODE AN+W-CODE = NOT
  822.                 IF  " NOT AN+W OR DN"  "ILLEGAL  THEN
  823.                GET-DESTINATION-MODE  DN-CODE = NOT
  824.                IF   " NOT DN"  "ILLEGAL  THEN
  825.                GET-DESTINATION-REGISTER  OR
  826.          THEN  SIZE @ CASE
  827.                LONG-SIZE  OF  6 SET-BIT  ENDOF
  828.                WORD-SIZE  OF  ENDOF  " BYTE" "ILLEGAL ENDCASE
  829.                W,(T)  A-FINIS   ;  DECIMAL
  830.  
  831. BINARY
  832. : TRAP  ( VECTOR# --- )   GET-SOURCE-MODE  #-CODE = NOT
  833.         IF  " NOT IMMEDIATE"  "ILLEGAL
  834.         THEN  1 SOURCE-ARRAY @  1111 AND
  835.         0100111001000000  OR  W,(T)
  836.         CLR-SOURCE  CLR-DESTINATION  A-FINIS  ;
  837.  
  838. BINARY
  839. : CMPM   GET-SOURCE-MODE  A@+-CODE =
  840.    GET-DESTINATION-MODE  A@+-CODE = AND NOT
  841.     IF     " NOT A@+"  "ILLEGAL
  842.     THEN   1011000100001000  ( OPCODEM )  [ DECIMAL ]
  843.    GET-SOURCE-REGISTER OR   SIZE @ OR
  844.    GET-DESTINATION-REGISTER  9 +SHIFT OR W,(T) A-FINIS ;
  845.  
  846. BINARY
  847. : MOVEQ  ( SIZE-WARNING? ) LONG-SIZE SIZE !
  848.         GET-DESTINATION-MODE  DN-CODE =  NOT
  849.         IF      " NOT DN"  "ILLEGAL
  850.         THEN  GET-SOURCE-MODE  #-CODE = NOT
  851.         IF      " NOT IMMEDIATE" "ILLEGAL
  852.         THEN  0111000000000000  ( OPCODEM )  [ DECIMAL ]
  853.         GET-DESTINATION-REGISTER 9 +SHIFT OR
  854.         1 SOURCE-ARRAY @ [ HEX ] 0FF AND   OR   W,(T)
  855.         CLR-SOURCE  A-FINIS  ;
  856.  
  857. ( TYPE6:   MOVE  )
  858. DECIMAL     ( USED BY MOVE ONLY...WILL REVERT TO MOVEQ )
  859. : TYPE6   ( SOURCEM DESTM --- )
  860.    CREATE  ALLOT-SPACE  DESTM, SOURCEM, 0 OPCODE,
  861.    DOES>  GET-SOURCE-MODE #-CODE =
  862.     GET-DESTINATION-MODE DN-CODE =   [ FORTH ] AND [ ASSEMBLER ]
  863.     1 SOURCE-ARRAY @ ABS 128 <       [ FORTH ] AND [ ASSEMBLER ]
  864.     2 SOURCE-ARRAY @ 0=              [ FORTH ] AND [ ASSEMBLER ]
  865.     QUICK @ 0= 0=    [ FORTH ] AND [ ASSEMBLER ]   TRUE QUICK !
  866.     IF    DROP MOVEQ
  867.     ELSE  MASKS !   SOURCE?  DESTINATION?
  868.           OPCODEM @   SIZE @ ALT/MOVE/SIZE OR
  869.           GET-SOURCE-EA OR
  870.           GET-DESTINATION-EA  TO-MOVE/DESTINATION OR
  871.           ?AN/BYTE/SOURCE   ?AN/BYTE/DESTINATION  W,(T) A-FINIS
  872.     THEN    ;  
  873.  
  874. BINARY
  875. : LINK    GET-SOURCE-MODE  AN-CODE = NOT
  876.   IF
  877.          " NOT AN"  "ILLEGAL
  878.   THEN
  879.   GET-DESTINATION-MODE  #-CODE = NOT
  880.   IF
  881.        " NOT IMMEDIATE"  "ILLEGAL
  882.   THEN
  883.   WORD-SIZE SIZE !   ( mdh force word size for offset w,<t> )
  884.   0100111001010000 ( OPCODEM ) GET-SOURCE-REGISTER OR W,(T) A-FINIS  ;
  885.  
  886. BINARY
  887. : DO-#-BIT  ( ---OPCODE )
  888.     0000,1000,0000,0000  GET-DESTINATION-EA OR
  889.                       OPCODEM             @ OR        ;
  890.  
  891. : DO-DN-BIT  ( ---OPCODE )
  892.     000,00001,0000,0000  GET-DESTINATION-EA OR  [ DECIMAL ]
  893.        GET-SOURCE-REGISTER  9 +SHIFT   OR
  894.                     OPCODEM              @  OR         ;
  895.  
  896. DECIMAL
  897. : DN/LONG-ELSE-BYTE  ( -- ) SIZE @
  898.       GET-DESTINATION-MODE DN-CODE =
  899.       IF    LONG-SIZE = NOT
  900.             IF     " LONG ONLY; OTHERS" "ILLEGAL
  901.             THEN
  902.       ELSE  BYTE-SIZE = NOT
  903.             IF      " BYTE ONLY; OTHERS" "ILLEGAL
  904.             THEN
  905.       THEN  ;
  906.  
  907. ( TYPE16:  BIT  )
  908. BINARY
  909. : TYPE16  ( DESTM OPCODE ---  )
  910.     CREATE   ALLOT-SPACE
  911.        OPCODE,   100000000001 SOURCEM,   DESTM,   101 SIZEM,
  912.     DOES> MASKS ! SOURCE?  SIZE?
  913.        GET-SOURCE-MODE  #-CODE =
  914.        IF    DO-#-BIT  DN/LONG-ELSE-BYTE  W,(T)  ( OPCODE )
  915.              1 SOURCE-ARRAY @ W,(T)      ( BIT#  )
  916.        ELSE  DO-DN-BIT  DN/LONG-ELSE-BYTE W,(T)
  917.        THEN  ( A-FINIS -- mdh 01/24/87 -- )
  918.              0 DESTINATION-ARRAY   ADD-[EXT]   INIT-ASM  ;
  919.  
  920. ( TYPE17:  BRANCHES )
  921. BINARY
  922. : TYPE17  
  923.     CREATE  ALLOT-SPACE [ DECIMAL ]
  924.           ( condition-code )  8 +SHIFT  [ BINARY ]
  925.           0110000000000000   OR  OPCODE,  110 SIZEM,
  926.     DOES>  MASKS !  ( displacment---) (  size-warning?  )
  927.           SIZE @  LONG-SIZE =  
  928.           IF   WORD-SIZE  SIZE !
  929.           THEN HAVE-SOURCE? 
  930.           IF      " ALL MODES"  "ILLEGAL 
  931.           THEN  [ DECIMAL ]  OPCODEM @  W,(T)
  932.           SIZE @ BYTE-SIZE =
  933.           IF    BYTE-RELATIVE
  934.           ELSE  WORD-RELATIVE
  935.           THEN     A-FINIS  ;
  936.  
  937. ( TYPE17.25:  BRANCHES )
  938. BINARY
  939. : TYPE17.25  
  940.     CREATE  ALLOT-SPACE [ DECIMAL ]
  941.           ( condition-code )  8 +SHIFT  [ BINARY ]
  942.           0110,0001,0000,0000   OR  OPCODE,  110 SIZEM,
  943.     DOES>  MASKS !  ( displacment---) (  size-warning?  )
  944.           SIZE @  BYTE-SIZE = 
  945.           IF   ." BSR only support WORD branches" cr
  946.           THEN
  947.           WORD-SIZE  SIZE ! 
  948. \          SIZE @  LONG-SIZE = 
  949. \          IF   WORD-SIZE  SIZE ! 
  950. \          THEN
  951.           HAVE-SOURCE? 
  952.           IF     " ALL MODES"  "ILLEGAL  \ quit 
  953.           THEN
  954.           [ DECIMAL ]
  955. \          SIZE @ BYTE-SIZE =
  956. \          IF    BYTE-RELATIVE
  957. \          ELSE  WORD-RELATIVE
  958. \          THEN     A-FINIS
  959.      here 2+ - 
  960.     dup abs $ 7FFF >
  961.     IF " BSR attemped over 32K" $error
  962.     ELSE   OPCODEM @  W,(T)   w,(t)
  963.     THEN  A-FINIS
  964. ;
  965.  
  966. ( TYPE17.5  DBCC ETC... )
  967. BINARY   ( <DN> <LABEL> WORD DB<XX>  )
  968. : TYPE17.5  
  969.     CREATE  ALLOT-SPACE [ DECIMAL ]
  970.           ( CONDITION-CODE )  8 +SHIFT  [ BINARY ]
  971.           0101000011001000  OR  OPCODE,  010 SIZEM,
  972.           100000000000 SOURCEM,  ( DN ONLY )
  973.     DOES>  MASKS !  ( DISPLACMENT---)
  974.           SIZE-WARNING?
  975.           WORD-SIZE  SIZE ! 
  976.           SOURCE?
  977.           OPCODEM @  GET-SOURCE-REGISTER OR   W,(T)
  978.           WORD-RELATIVE    A-FINIS    ;
  979.  
  980. ( TYPE18  SET-BY-CONDITION )
  981. BINARY
  982. : TYPE18  
  983.     CREATE  ALLOT-SPACE [ DECIMAL ]
  984.           ( CONDITION-CODE )  8 +SHIFT  [ BINARY ]
  985.           0101000011000000  OR  OPCODE,  100 SIZEM,
  986.           101111111000  SOURCEM,
  987.     DOES>  MASKS !  SIZE?   SOURCE?
  988.           OPCODEM @  GET-SOURCE-EA OR  W,(T)  A-FINIS  ;
  989.  
  990. HEX
  991. : DATA-REG?  ( REG+BIT--REG F) DUP 10 AND SWAP 07 AND SWAP ;
  992.  
  993. : REG-MASK   ( REG1 REG2...REGN--MASK )
  994.    #REGISTERS  @
  995.      IF     0   #REGISTERS @  0
  996.             DO    ( REGS...MASK---)  SWAP  DATA-REG?
  997.                   IF     SET-BIT
  998.                   ELSE   8 +  SET-BIT
  999.                  THEN
  1000.             LOOP
  1001.      ELSE   0
  1002.      THEN   ; 
  1003.  
  1004. DECIMAL
  1005. : -REG-MASK  ( REG1 REG2...REGN--MASK )
  1006.          0 #REGISTERS @ -DUP
  1007.       IF 0  DO SWAP DATA-REG? NOT
  1008.                IF 7 SWAP -
  1009.                ELSE 15 SWAP -
  1010.                THEN SET-BIT
  1011.             LOOP
  1012.       THEN  ;
  1013.  
  1014. DECIMAL
  1015. : HANDLE-MOVEM-DIRECTION  ( OPCODE---OPCODE' )
  1016.       REGISTER-PENDING  @
  1017.                IF    ( RAM TO REG )  SOURCE?  10 SET-BIT
  1018.                ELSE  ( REG TO RAM )  SWAP-SOURCE-DEST
  1019.                      DESTINATION?    SWAP-SOURCE-DEST
  1020.                THEN
  1021.       GET-SOURCE-MODE  -A@-CODE =  REGISTER-PENDING @ AND
  1022.                 IF  " RAM TO REG WITH -A@" "ILLEGAL THEN
  1023.       GET-SOURCE-MODE  A@+-CODE = REGISTER-PENDING @ NOT AND
  1024.                 IF  " REG TO RAM WITH A@+" "ILLEGAL  THEN  ;
  1025.  
  1026. BINARY
  1027. : MOVEM-TYPE  
  1028.     CREATE  ALLOT-SPACE  011 SIZEM,
  1029.             0100100010000000 OPCODE,
  1030.             001011111000 DESTM,  ( REGISTER TO RAM )
  1031.             001101111110 SOURCEM, ( RAM TO REGISTER )  [ DECIMAL ] 
  1032.     DOES>   MASKS !  SIZE?   OPCODEM @
  1033.             GET-SOURCE-EA OR   SIZE @ LONG-SIZE =
  1034.             IF    6 SET-BIT 
  1035.             THEN  HANDLE-MOVEM-DIRECTION  W,(T)
  1036.                GET-SOURCE-MODE -A@-CODE =
  1037.             IF    -REG-MASK  
  1038.             ELSE   REG-MASK 
  1039.             THEN   W,(T)    A-FINIS    ; 
  1040.  
  1041. DECIMAL
  1042. MOVEM-TYPE  MOVEM  ( A@+ : MEM->REG : DR0->DR7,A0->A7.  )
  1043.                    ( -A@ : REG->MEM : A7->A0,D7->D0.    )
  1044.                   ( ELSE : MEM+     : D0->D7,A0->A7.    )
  1045.  
  1046. : ADDRESSES?   HAVE-SOURCE?   HAVE-DESTINATION?  AND
  1047.           IF   " TOO MANY MODES; "  $ERROR THEN ;
  1048. HEX
  1049. : DATA?   ( N1---N1 ) DUP 10 AND 
  1050.       IF    " MUST BE AN ADDRESS REG: " $ERROR 
  1051.       THEN ;
  1052.  
  1053. : ADDRESS? ( N1---N2 )  ( STRIPS DN MARK TOO ) DUP 10 AND  NOT 
  1054.     IF     " MUST BE A DATA REG: " $ERROR
  1055.     THEN  7 AND ;
  1056.  
  1057. BINARY
  1058. : ->DESTINATION  ( MODE/REG---REG/MOD/000000 )
  1059.       DUP 111 AND   [ DECIMAL ]  3 +SHIFT  SWAP
  1060.     [ BINARY ] 111000 AND [ DECIMAL ] 3 -SHIFT
  1061.     OR  6 +SHIFT  ;
  1062.  
  1063. DECIMAL
  1064. : MODE ( MODE-#REG---) HAVE-SOURCE? 
  1065.     IF    0 DESTINATION-ARRAY !   HAVE-DESTINATION
  1066.     ELSE  0 SOURCE-ARRAY ! HAVE-SOURCE 
  1067.     THEN ;
  1068.  
  1069. : ADDR-MODE ( REG# MODE---) SWAP DATA? ADDRESSES? OR MODE ;
  1070.  
  1071. : FROM-#REGISTERS  ( N-- ) #REGISTERS +!
  1072.        FALSE REGISTER-PENDING !  ;
  1073.  
  1074. : DN ( REG#---) ADDRESS? DN-CODE OR MODE -1 FROM-#REGISTERS ;
  1075.  
  1076. : AN ( REG#--- )  AN-CODE  ADDR-MODE -1 FROM-#REGISTERS ;
  1077.  
  1078. : A@ ( REG#---)   A@-CODE  ADDR-MODE -1 FROM-#REGISTERS ;
  1079.  
  1080. : A@+ ( REG#---)  A@+-CODE ADDR-MODE -1 FROM-#REGISTERS ;
  1081.  
  1082. : -A@  ( REG#---) -A@-CODE ADDR-MODE -1 FROM-#REGISTERS ;
  1083.  
  1084. : AN+W  ( AREG N---) 1 ADDRESS-ARRAY! AN+W-CODE ADDR-MODE
  1085.         -1 FROM-#REGISTERS  ;
  1086.  
  1087. : MODE-SIZE  ( --- )  ( SETS SIZE FOR MODE )  SIZE-SET?  @
  1088.      IF     SIZE @   FALSE SIZE-SET? !  LONG-SIZE SIZE !
  1089.      ELSE   -1   ( FLAG FOR USE DEFAULT SIZE )
  1090.      THEN   4 ADDRESS-ARRAY !               ;
  1091.  
  1092. : AN+R+B  ( AREG REG BYTE---) 2 ADDRESS-ARRAY! 1 ADDRESS-ARRAY!
  1093.           MODE-SIZE  AN+R+B-CODE ADDR-MODE -2 FROM-#REGISTERS  ;
  1094.  
  1095.  ASSEMBLER  DEFINITIONS
  1096. : MAKE-DOUBLE  ( N-OR-D --- D )  DPL @ -1 =
  1097.     IF   0    THEN   -1 DPL !    ;
  1098.  
  1099. : ABS.W  ( N---) 1 ADDRESS-ARRAY!  ABS.W@-CODE  MODE
  1100.                  0 FROM-#REGISTERS  ;
  1101.  
  1102. : ABS.L  ( N.LSW N.MSW---) MAKE-DOUBLE  2 ADDRESS-ARRAY!
  1103.   1 ADDRESS-ARRAY!    ABS.L@-CODE MODE  0 FROM-#REGISTERS  ;
  1104.  
  1105. : PC+W  ( W ---)  1 ADDRESS-ARRAY!  PC+W-CODE MODE
  1106.      ( -1 FROM-#REGISTERS )  ;
  1107.  
  1108. : PC+R+B  ( REG BYTE---) 2 ADDRESS-ARRAY!  1 ADDRESS-ARRAY!
  1109.     MODE-SIZE   PC+R+B-CODE  MODE -1 FROM-#REGISTERS  ;
  1110.  
  1111. : #  ( N-OR-D---) MAKE-DOUBLE
  1112.   2 ADDRESS-ARRAY!   1 ADDRESS-ARRAY!   #-CODE MODE       ;
  1113.  
  1114. HEX
  1115. 4E77 TYPE1 RTR
  1116. 4E76 TYPE1 TRAPV
  1117. 4E75 TYPE1 RTS
  1118. 4E73 TYPE1 RTE
  1119. 4E70 TYPE1 RESET
  1120. 4E71 TYPE1 NOP
  1121.  ( 4AFC TYPE1 ILLEGAL  )
  1122.  
  1123. 4E72 TYPE2 STOP
  1124. 027C TYPE2 ANDI-SR
  1125. 0A7C TYPE2 EORI-SR
  1126. 007C TYPE2 ORI-SR
  1127.  
  1128. 023C TYPE3 ANDI-CCR
  1129. 0A3C TYPE3 EORI-CCR
  1130. 003C TYPE3 ORI-CCR
  1131.  
  1132.    4200 TYPE4 CLR
  1133.    4400 TYPE4 NEG
  1134.    4600 TYPE4 NOT
  1135.    4A00 TYPE4 TST
  1136.    4000 TYPE4 NEGX
  1137.  
  1138. (  USE:  N1 ADDRESSING-MODE SIZE TYPE5-WORD )
  1139.    0C00 TYPE5 CMPI
  1140.    0000 TYPE5 ORI
  1141.    0200 TYPE5 ANDI
  1142.    0400 TYPE5 SUBI
  1143.    0600 TYPE5 ADDI
  1144.    0A00 TYPE5 EORI
  1145.  
  1146.  
  1147. BINARY
  1148. ( SOURCEM   DESTM  )
  1149. 111111111111 111111111000 TYPE6 MOVE
  1150.  
  1151. BINARY
  1152. ( EXC  DESTM       SOURCEM       OPCODE   )
  1153. 00000 101111111111 001111111000 1100000000000000 TYPE7 AND
  1154. 00000 101111111111 001111111000 1000000000000000 TYPE7 OR
  1155. 01000 111111111111 001111111000 1001000000000000 TYPE7 SUB
  1156. 11010 010000000000 111111111111 1001000000000000 TYPE7 SUBA
  1157. 01000 111111111111 001111111000 1101000000000000 TYPE7 ADD
  1158. 11010 010000000000 111111111111 1101000000000000 TYPE7 ADDA
  1159. 00010 101111111000 100000000000 1011000000000000 TYPE7 EOR
  1160. 01101 110000000000 111111111111 1011000000000000 TYPE7 CMP
  1161. ( EXCEPTIONS:   AN/BYTE/SOURCE   SRC-IS-DN!    DEST-IS-DN! )
  1162. (        BIT:   2                1             0             )
  1163. (               AN/BYTE/DESTINATION                          )
  1164. (        BIT:   3                                            )
  1165.  
  1166. BINARY
  1167. ( SOURCEM       DESTM      SIZEM    OPCODE )
  1168. 101111111111  100000000000  010  HEX C1C0 TYPE8 MULS   BINARY
  1169. 101111111111  100000000000  010  HEX C0C0 TYPE8 MULU   BINARY
  1170. 101111111111  100000000000  010  HEX 4180 TYPE8 CHK    BINARY
  1171. 101111111111  100000000000  010  HEX 81C0 TYPE8 DIVS   BINARY
  1172. 101111111111  100000000000  010  HEX 80C0 TYPE8 DIVU   BINARY
  1173. 001001111110  010000000000  001  HEX 41C0 TYPE8 LEA    DECIMAL
  1174.  
  1175. BINARY
  1176. ( DESTM      SIZEM  OPCODE  )
  1177. 111111111000 111 0101000100000000 TYPE9 SUBQ
  1178. 111111111000 111 0101000000000000 TYPE9 ADDQ
  1179.  
  1180.  
  1181. ( SOURCEM       SIZEM  OPCODE         )
  1182.  100000000000  010 0100100001000000 TYPE10 SWAP
  1183.  010000000000  111 0100111001011000 TYPE10 UNLK
  1184.  010000000000  001 0100111001100000 TYPE10 MOVE-TO-USP
  1185.  010000000000  001 0100111001101000 TYPE10 MOVE-FROM-USP
  1186.  
  1187. ( EXCEPTIONS:  ALT-SIZE  AN/BYTE/SOURCE  X   X   )
  1188. ( SOURCEM       SIZEM  OPCODE         )
  1189.  100000000000  011 0100100000000000 TYPE10.5 EXT
  1190.  
  1191. ( TYPE11  TYPE11.5  TYPE12    DEFINITIONS  )
  1192. BINARY
  1193. ( SOURCEM       SIZEM     OPCODE    )
  1194. 1011,1111,1111   010    HEX  46C0 BINARY TYPE11 MOVE-TO-SR
  1195. 1011,1111,1000   010    HEX  44C0 BINARY TYPE11 MOVE-TO-CCR
  1196. 1011,1111,1000   100    HEX  4AC0 BINARY TYPE11 TAS
  1197. 1011,1111,1000   010    HEX  40C0 BINARY TYPE11 MOVE-FROM-SR
  1198. 0010,0111,1110   001    HEX  48C0 BINARY TYPE11 PEA
  1199. 0010,0111,1110   001    HEX  4EC0 BINARY TYPE11 JMP
  1200. 0010,0111,1110   001    HEX  4E80 BINARY TYPE11 JSR
  1201. 1011,1111,1000   100    HEX  4800 BINARY TYPE11 NBCD
  1202.  
  1203. TYPE12 EXG
  1204.  
  1205. BINARY
  1206. 1110011011011000 TYPE13 ROR     ( E6D8 )
  1207. 1110011111011000 TYPE13 ROL     ( E7D8 )
  1208. 1110001011001000 TYPE13 LSR     ( E2C8 )
  1209. 1110001111001000 TYPE13 LSL     ( E3C8 )
  1210. 1110010011010000 TYPE13 ROXR    ( E4D0 )
  1211. 1110010111010000 TYPE13 ROXL    ( E5D0 )
  1212. 1110000011000000 TYPE13 ASR     ( E0C0 )
  1213. 1110000111000000 TYPE13 ASL     ( E1C0 )
  1214.  
  1215. ( OPCODE )
  1216. 1101000100000000  TYPE14  ADDX
  1217. 1001000100000000  TYPE14  SUBX
  1218.  
  1219. ( OPCODEM  )
  1220. 1100000100000000  TYPE15  ABCD
  1221. 1000000100000000  TYPE15  SBCD
  1222.  
  1223. ( DESTM       TYPE     CODE )
  1224. 101111111000 01000000 TYPE16 BCHG
  1225. 101111111000 10000000 TYPE16 BCLR
  1226. 101111111000 11000000 TYPE16 BSET
  1227. 101111111110 00000000 TYPE16 BTST
  1228.  
  1229. ( CONDITION-CODE  )
  1230. 0100 TYPE17 BCC    0011 TYPE17 BLS
  1231. 0101 TYPE17 BCS    1101 TYPE17 BLT
  1232. 0111 TYPE17 BEQ    1011 TYPE17 BMI
  1233. 0110 TYPE17 BNE
  1234. 1100 TYPE17 BGE    1010 TYPE17 BPL
  1235. 1110 TYPE17 BGT    0000 TYPE17 BRA
  1236. 0010 TYPE17 BHI    1000 TYPE17 BVC
  1237. 1111 TYPE17 BLE    1001 TYPE17 BVS
  1238.  
  1239. 0001 TYPE17.25  BSR
  1240.  
  1241. ( CONDITION-CODE  )
  1242. 0100 TYPE17.5 DBCC    0011 TYPE17.5 DBLS
  1243. 0101 TYPE17.5 DBCS    1101 TYPE17.5 DBLT
  1244. 0111 TYPE17.5 DBEQ    1011 TYPE17.5 DBMI
  1245. 0110 TYPE17.5 DBNE    0001 TYPE17.5 DBF  0001 TYPE17.5 DBRA
  1246. 1100 TYPE17.5 DBGE    1010 TYPE17.5 DBPL
  1247. 1110 TYPE17.5 DBGT    0000 TYPE17.5 DBT
  1248. 0010 TYPE17.5 DBHI    1000 TYPE17.5 DBVC
  1249. 1111 TYPE17.5 DBLE    1001 TYPE17.5 DBVS
  1250. ( OFFSET REG --- )
  1251.  
  1252. ( TYPE18 DEFINITIONS SET-BY-CONDITION )
  1253. BINARY
  1254. ( CONDITION-CODE  )
  1255. 0100 TYPE18 SCC    0011 TYPE18 SLS
  1256. 0101 TYPE18 SCS    1101 TYPE18 SLT
  1257. 0111 TYPE18 SEQ    1011 TYPE18 SMI
  1258. 0001 TYPE18 SF     0110 TYPE18 SNE
  1259. 1100 TYPE18 SGE    1010 TYPE18 SPL
  1260. 1110 TYPE18 SGT    0000 TYPE18 ST
  1261. 0010 TYPE18 SHI    1000 TYPE18 SVC
  1262. 1111 TYPE18 SLE    1001 TYPE18 SVS
  1263. DECIMAL
  1264.  
  1265.  
  1266. \ register definitions
  1267. 0 AREG TEMP0         
  1268. 0 AREG 0AR
  1269.  
  1270. 1 AREG TEMP1
  1271. 1 AREG 1AR
  1272.  
  1273. 2 AREG LOC 
  1274. 2 AREG 2AR
  1275.  
  1276. 3 AREG +64k
  1277. 3 AREG 3AR
  1278.  
  1279. 4 AREG ORG
  1280. 4 AREG 4AR
  1281.  
  1282. 5 AREG UP
  1283. 5 AREG 5AR
  1284.  
  1285. 6 AREG DSP
  1286. 6 AREG 6AR
  1287.  
  1288. 7 AREG RP 
  1289. 7 AREG 7AR
  1290.  
  1291. 0 DREG 0DR             
  1292. 1 DREG 1DR
  1293. 2 DREG 2DR             
  1294. 3 DREG 3DR
  1295. 4 DREG 4DR  
  1296.            
  1297. 5 DREG ILOOP
  1298. 5 DREG 5DR
  1299.  
  1300. 6 DREG JLOOP             
  1301. 6 DREG 6DR
  1302.  
  1303. 7 DREG TOS
  1304. 7 DREG 7DR
  1305. only FORTH DEFINITIONS
  1306. max-inline !
  1307.